home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b1nuC.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  8.3 KB  |  331 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b1nuC.c,v 1.4 85/08/22 16:50:36 timo Exp $
  5. */
  6.  
  7. #include <ctype.h>
  8. #include "b.h"
  9. #include "b0con.h"
  10. #include "b0fea.h"
  11. #include "b1obj.h"
  12. #include "b1mem.h"
  13. #include "b1num.h"
  14. #include "b2syn.h" /* temporary until numconst is fixed */
  15.  
  16. char *sprintf(); /* OS */
  17. extern value tento();
  18. extern integer int_tento();
  19.  
  20. #define EXPDIGITS 10    /* Extra positions to allow for exponent part */
  21.             /* -- must be larger than tenlogBASE */
  22. #define MAXDIGITS (MAXNUMDIG-1)    /* Max precision for fixed/floating numbers */
  23. #define CONVBUFSIZE (MAXDIGITS+4)
  24.             /* Maximum number of digits to print in integer notation */
  25.             /* (4 is the size of 'e+00' added by sprintf) */
  26.  
  27.  
  28. /* Convert an integer to a C character string.
  29.    The character string is overwritten on each next call.
  30.    It assumes BASE is a power of 10. */
  31.  
  32. Hidden char *convint(v) register integer v; {
  33.     static char *buffer, shortbuffer[tenlogBASE+3];
  34.     static char fmt[10];
  35.     register char *cp;
  36.     register int i;
  37.     bool neg = No;
  38.  
  39.     if (IsSmallInt(v)) {
  40.         sprintf(shortbuffer, "%d", SmallIntVal(v));
  41.         return shortbuffer;
  42.     }
  43.  
  44.     if (Digit(v, Length(v)-1) < 0) {
  45.         neg = Yes;
  46.         v = int_neg(v);
  47.     }
  48.     if (buffer) freemem(buffer);
  49.     buffer = getmem((unsigned)(Length(v)*tenlogBASE + 1 + neg));
  50.     cp = buffer;
  51.     if (neg) *cp++ = '-';
  52.     sprintf(cp, "%d", Msd(v));
  53.     if (!IsSmallInt(v)) {
  54.         if (!*fmt) sprintf(fmt, "%%0%dd", tenlogBASE);
  55.         while (*cp) ++cp;
  56.         for (i = Length(v)-2; i >= 0; --i, cp += tenlogBASE)
  57.             sprintf(cp, fmt, Digit(v, i));
  58.         if (neg) release((value) v);
  59.     }
  60.     return buffer;
  61. }
  62.  
  63. #ifdef EXT_RANGE
  64.  
  65. /* This is terrible.  But never mind, it'll all change (sometimes). */
  66.  
  67. Hidden bool hugenumber(v) value v; {
  68.     bool huge;
  69.     real w = (real) approximate(v);
  70.     huge = Expo(w) > Maxexpo || Expo(w) < Minexpo && Frac(w) != 0;
  71.     release((value)w);
  72.     return huge;
  73. }
  74.  
  75.  
  76. Hidden string convapp(v) value v; {
  77.     value absv, tenlogv, expo, tentoexpo, frac;
  78.     static char buf[100];
  79.     char fmt[15];
  80.     int precision;
  81.     double fracval, expoval, i;
  82.  
  83.     absv = absval(v);
  84.     tenlogv = log2((value)int_10, absv), release(absv);
  85.     expo = floorf(tenlogv), release(tenlogv);
  86.     expoval = numval(expo), release(expo);
  87.     if (expoval*tenlogBASE >= Maxintlet || expoval*tenlogBASE <= -Maxintlet) {
  88.         expo = (value) mk_approx(expoval, 0.0);
  89.         tentoexpo = power((value)int_10, expo), release(expo);
  90.     }
  91.     else
  92.         tentoexpo = tento((int)expoval);
  93.     frac = quot(v, tentoexpo), release(tentoexpo);
  94.     fracval = numval(frac), release(frac);
  95.     while (fabs(fracval) >= 10) fracval /= 10, ++expoval;
  96.     while (fabs(fracval) < 1) fracval *= 10, --expoval;
  97.     precision = MAXDIGITS;
  98.     i = expoval < 0 ? -expoval : expoval;
  99.     while (i >= 10 && precision > 2) --precision, i /= 10;
  100.         /* Loose precision for large exponents! */
  101.         /* :-( But keep some too! )-: */
  102.     sprintf(fmt, "%%.%dlgE%%s%%2.0lf", precision);
  103.     sprintf(buf, fmt, fracval, expoval >= 0 ? "+" : "", expoval);
  104.     return buf;
  105. }
  106.  
  107. #endif EXT_RANGE
  108.  
  109. /* Convert a numeric value to a C character string.
  110.    The character string is overwritten on each next call. */
  111.  
  112. Visible string convnum(v) register value v; {
  113.     static char convbuf[3+CONVBUFSIZE+EXPDIGITS];
  114.         /* 3 extra for things (sign, 0.) to be stuck on front of it */
  115.     static char fmt[10];
  116.     char *bufstart = convbuf+3;
  117.     register char *cp = bufstart;
  118.     double x;
  119.  
  120.     if (Integral(v)) return convint((integer)v);
  121. #ifdef EXT_RANGE
  122.     if (hugenumber(v)) return convapp(v);
  123. #endif
  124.  
  125.     /* Reasonably-sized reals and rationals are treated alike.
  126.        However, not-too-large rationals resulting from
  127.        'n round x' are transformed to f-format. */
  128.  
  129.     x = numval(v);
  130.     if (!*fmt) sprintf(fmt, "%%.%dlg", MAXDIGITS);
  131.     sprintf(bufstart, fmt, x);
  132.  
  133.     for (cp = bufstart; *cp != '\0'; ++cp)
  134.         if (*cp == 'e') {    /* change sprintf's 'e' to 'E' */
  135.             *cp = 'E';
  136.             break;
  137.         }
  138.  
  139. #ifdef IBMPC
  140.     if (*cp != 'E') {
  141.         /* Delete trailing zeros after decimal pt; don't rely on %g */
  142.         for (cp = bufstart; *cp != '\0' && *cp != '.'; ++cp)
  143.             ;
  144.         if (*cp == '.') {
  145.             char *ep;
  146.             for (; *cp != '\0' && *cp != 'E'; ++cp)
  147.                 ;
  148.             ep = cp;
  149.             while (*--cp == '0')
  150.                 ;
  151.             if (++cp < ep) {
  152.                 while (*ep != '\0')
  153.                     *cp++ = *ep++;
  154.                 *cp = '\0';
  155.             }
  156.         }
  157.     }
  158. #endif IBMPC
  159.  
  160.     if (Rational(v) && Roundsize(v) > 0 && *cp != 'E') {
  161.         int i = Roundsize(v);
  162.         int j = 1;
  163.             /* Counts digits allowed beyond MAXDIGITS, 1 for '.' */
  164.  
  165.         for (cp = bufstart; *cp == '0'; ++cp)
  166.             ++j; /* Allow a trailing zero for each leading zero */
  167.  
  168.         for (; *cp != '\0' && *cp != '.'; ++cp)
  169.             ; /* Find '.' or end of string */
  170.  
  171.         if (*cp == '\0') {
  172.             *cp = '.'; /* Append '.' if not found */
  173.             *++cp = '\0';
  174.         }
  175.         else {
  176.             while (*++cp == '0')
  177.                 /* Allow more precision if leading zeros */
  178.                 ++j, --i;
  179.             while (*cp != '\0')
  180.                 --i, ++cp; /* Find last digit */
  181.         }
  182.  
  183.         /* Append extra zeros (but don't show more precision
  184.            than sprintf can!) */
  185.         while (--i >= 0 && cp < bufstart+MAXDIGITS+j)
  186.             *cp++ = '0';
  187.  
  188.         *cp = '\0'; /* Append new terminating null byte */
  189.     }
  190.  
  191.     return bufstart;
  192. }
  193.  
  194.  
  195. /* Convert a string to a number (assume it's syntactically correct!).
  196.    Pointers to the first and last+1 characters are given.
  197.    Again, BASE must be a power of 10.
  198.    ********** NEW **********
  199.    If E_EXACT is defined, all numbers input are made exact, even if
  200.    E-notation is used.
  201.    ********** WARNING **********
  202.    This routine must be fixed, because it accesses the source buffer
  203.    and it shouldn't because it's in the wrong place in the hierarchy
  204. */
  205.  
  206. Visible value numconst(text, end) register txptr text, end; {
  207.     register txptr tp;
  208.     register int numdigs, fraclen;
  209.     integer a;
  210.     register digit accu;
  211.     value c;
  212.  
  213.     if (Char(text) == 'E') a = int_1;
  214.     else {
  215.         while (text<end && Char(text)=='0') ++text; /* Skip leading zeros */
  216.  
  217.         for (tp = text; tp<end && isdigit(Char(tp)); ++tp)
  218.             ; /* Count integral digits */
  219.         numdigs = tp-text;
  220.         fraclen = 0;
  221.         if (tp<end && Char(tp)=='.') {
  222.             ++tp;
  223.             for (; tp<end && isdigit(Char(tp)); ++tp)
  224.                 ++fraclen; /* Count fractional digits */
  225.             numdigs += fraclen;
  226.         }
  227.         a = (integer) grab_num((numdigs+tenlogBASE-1) / tenlogBASE);
  228.         if (!a) return Vnil; /* Recovered error */
  229.         accu = 0;
  230.         /* Integer part: */
  231.         for (; text<end && isdigit(Char(text)); ++text) {
  232.             accu = accu*10 + Char(text)-'0';
  233.             --numdigs;
  234.             if (numdigs%tenlogBASE == 0) {
  235.                 Digit(a, numdigs/tenlogBASE) = accu;
  236.                 accu = 0;
  237.             }
  238.         }
  239.         /* Fraction: */
  240.         if (text < end && Char(text) == '.') {
  241.             ++text;
  242.             for (; text<end && isdigit(Char(text)); ++text) {
  243.                 accu = accu*10 + Char(text)-'0';
  244.                 --numdigs;
  245.                 if (numdigs%tenlogBASE == 0) {
  246.                     Digit(a, numdigs/tenlogBASE) = accu;
  247.                     accu = 0;
  248.                 }
  249.             }
  250.         }
  251.         if (numdigs != 0) syserr(MESS(800, "numconst: can't happen"));
  252.         a = int_canon(a);
  253.     }
  254.  
  255.     /* Exponent: */
  256.     if (text >= end || Char(text) != 'E') {
  257.         integer b = int_tento(fraclen);
  258.         c = mk_exact(a, b, fraclen);
  259.         release((value) b);
  260.     }
  261.     else {
  262.         double expo = 0;
  263.         int sign = 1;
  264.         value b;
  265.         ++text;
  266.         if (text < end) {
  267.             if (Char(text) == '+') ++text;
  268.             else if (Char(text) == '-') {
  269.                 ++text;
  270.                 sign = -1;
  271.             }
  272.         }
  273.         for (; text<end && isdigit(Char(text)); ++text) {
  274.             expo = expo*10 + Char(text)-'0';
  275.             if (expo > Maxint) {
  276.                 error(MESS(801, "excessive exponent in E-notation"));
  277.                 expo = 0;
  278.                 break;
  279.             }
  280.         }
  281.         b = tento((int)expo * sign - fraclen);
  282. #ifndef E_EXACT
  283.         /* Make approximate number if E-notation used */
  284.         c = approximate(b);
  285.         release(b);
  286.         b = c;
  287. #endif
  288.         if (a == int_1) c = b;
  289.         else c = prod((value)a, b), release(b);
  290.     }
  291.     release((value) a);
  292.     return c;
  293. }
  294.  
  295.  
  296. /*
  297.  * printnum(f, v) writes a number v on file f in such a way that it
  298.  * can be read back identically, assuming integral powers of ~2 can be
  299.  * computed exactly.  (This is necessary for the permanent environment.)
  300.  */
  301.  
  302. Visible Procedure printnum(f, v) FILE *f; value v; {
  303.     if (Approximate(v)) {
  304. #ifdef PRINT_APPROX
  305.         if (Frac((real)v) == 0) fprintf(f, "~0");
  306.         else {
  307.             static char fmt[25];
  308.             if (!*fmt)
  309.                 sprintf(fmt, "%%.%dlgE0*~2**%%.0lf", MAXDIGITS+2);
  310.             fprintf(f, fmt, Frac((real)v), Expo((real)v));
  311.         }
  312.         return;
  313. #else
  314.         fputc('~', f);
  315. #endif
  316.     }
  317.     if (Rational(v) && Denominator((rational)v) != int_1) {
  318.         int i = Roundsize(v);
  319.         fputs(convnum((value)Numerator((rational)v)), f);
  320.         if (i > 0 && i <= MAXDIGITS) {
  321.             /* The assumption here is that in u/v, the Roundsize
  322.                of the result is the sum of that of the operands. */
  323.             putc('.', f);
  324.             do putc('0', f); while (--i > 0);
  325.         }
  326.         putc('/', f);
  327.         v = (value) Denominator((rational)v);
  328.     }
  329.     fputs(convnum(v), f);
  330. }
  331.